home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / IO.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  16.6 KB  |  527 lines
  1. ; IO.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Standard Scheme Input/Output Routines            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 10 Feb 87:    READ modified for R^3 quasi/quote            *
  18. ;*        READ-STRING removed and coded in assembler        *
  19. ;*        Random I/O included from David Stevens (tc)        *
  20. ;* - 2 Jun 87:    Open-binary-input-file,open-binary-output-file        *
  21. ;*        compile, etc. removed and placed in COMP.S        *
  22. ;*         for building of compiler-less system            *
  23. ;*        LOAD is just defined in terms of FAST-LOAD        *
  24. ;*         for compilerless systems. Its real definition        *
  25. ;*         is in COMP.S. (tc)                    *
  26. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  27. ;* - 15 Dec 92: Added PEEK-CHAR for R4RS; added READ-SW for sweb (mv)    *
  28. ;* - 25 Dec 92: Added SPLIT-FILENAME using %ESC                *
  29. ;*                                    *
  30. ;*                    ``In nomine omnipotentii dei''    *
  31. ;************************************************************************
  32.  
  33. ; The following definitions are used only at compile time for readability 
  34. ; and understanding. They will not be written out to the .so file.
  35. ; See pboot.s and compile.all.
  36.  
  37.     (compile-time-alias %read-file-flag   #b00000001)    ; read flag
  38.     (compile-time-alias %write-file-flag  #b00000011)    ; write flag(s)
  39.     (compile-time-alias %window-flag      #b00000100)    ; window port
  40.     (compile-time-alias %open-file-flag   #b00001000)    ; open port
  41.     (compile-time-alias %binary-file-flag #b00100000)    ; binary file
  42.     (compile-time-alias %string-flag      #b01000000)    ; string file
  43.  
  44.  
  45. (define call-with-input-file                ; CALL-WITH-INPUT-FILE
  46.   (lambda (filename proc)
  47.     (let* ((port (open-input-file filename))
  48.        (answer (proc port)))
  49.       (close-input-port port)
  50.       answer)))
  51.  
  52.  
  53. (define call-with-output-file                ; CALL-WITH-OUTPUT-FILE
  54.   (lambda (filename proc)
  55.     (let* ((port (open-output-file filename))
  56.        (answer (proc port)))
  57.       (close-output-port port)
  58.       answer)))
  59.  
  60.  
  61. (define current-column                    ; CURRENT-COLUMN
  62.   (lambda args
  63.     (+ 1 (%reify-port (car args) 1))))
  64.  
  65.  
  66. (define-integrable current-input-port            ; CURRENT-INPUT-PORT
  67.   (lambda ()
  68.     (fluid input-port)))
  69.  
  70. (define-integrable current-output-port            ; CURRENT-OUTPUT-PORT
  71.   (lambda ()
  72.     (fluid output-port)))
  73.  
  74. (define eof-object?                    ; EOF-OBJECT?
  75.   (lambda (obj)
  76.     (eqv? obj eof)))        ; temporary ???
  77.  
  78.  
  79. ;;;
  80. ;;; Compile functions are now in PCOMP.S,               ; COMPILE
  81. ;;; which reflects compiler-only functions
  82. ;;;
  83.  
  84.  
  85. (define fast-load                    ; FAST-LOAD
  86.   (lambda (file)
  87.     (letrec ((fasl
  88.           (lambda (name)
  89.         (let ((pgm (%%fasl name)))
  90.           (when (not (eof-object? pgm))
  91.             (%execute pgm)
  92.             (fasl '() ))))))
  93.     (if (string? file)
  94.         (if (file-exists? file)
  95.         (begin
  96.           (fasl file)
  97.           'ok)
  98.         (error "FAST-LOAD file does not exist" file))
  99.         (%error-invalid-operand 'FAST-LOAD file)))))
  100.  
  101. (if (unbound? load)                      
  102.   (define load fast-load))                ; LOAD
  103.  
  104. (define file-exists?                    ; FILE-EXISTS?
  105.    (lambda (name)
  106.      (and (string? name)
  107.        (not (string-null? name))
  108.        (call/cc
  109.        (fluid-lambda (*file-exists-open*)
  110.           (let ((port (%open-port name 'read)))
  111.             (if (port? port)
  112.               (begin
  113.            (close-input-port port)
  114.            #T)
  115.         ;else
  116.           #F)))))))
  117.  
  118.  
  119. (define filename-split                    ; FILENAME-SPLIT
  120.   (lambda (name)
  121.     (if (string? name)
  122.     (read (open-input-string (%esc 6 name)))
  123.     (error "invalid argument to FILENAME-SPLIT" name))))
  124.  
  125. (define filename-merge                    ; FILENAME-MERGE
  126.   (lambda (path)
  127.     (apply string-append path)))
  128.  
  129. (define flush-input                    ; FLUSH-INPUT
  130.   (lambda args
  131.     (let ((x '())
  132.       (port (car args)))
  133.       (if (and (positive? (bitwise-and (%reify-port port 11) %open-file-flag))
  134.            (zero? (bitwise-and (%reify-port port 11) %read-file-flag))
  135.            (char-ready? port))
  136.       (do ((x (read-char port) (read-char port)) )
  137.           ((or (eq? x #\newline)
  138.            (eof-object? x)
  139.            (not (char-ready? port)))))))))
  140.  
  141.              
  142.  
  143. (define fresh-line                    ; FRESH-LINE
  144.   (lambda p
  145.     (when p (set! p (car p)))
  146.     (when (positive? (%reify-port p 1))
  147.       (newline p))))
  148.  
  149.  
  150. (define input-port?                    ; INPUT-PORT?
  151.   (lambda (p)
  152.     (and (port? p)
  153.          (let ((pflags (%reify-port p 11)))
  154.            (and (positive? (bitwise-and %open-file-flag pflags))
  155.             (zero? (bitwise-and %read-file-flag pflags)))))))
  156.  
  157. (define line-length                    ; LINE-LENGTH
  158.   (lambda args
  159.     (%reify-port (car args) 5)))
  160.  
  161. (define open-input-file                               ; OPEN-INPUT-FILE
  162.      (lambda (name) (%open-port name 'read)))
  163.  
  164. (define open-binary-input-file                        ; OPEN-BINARY-INPUT-FILE
  165.      (lambda (name)
  166.         (let ((port (%open-port name 'read)))
  167.           (%reify-port! 
  168.             port 
  169.             11
  170.             (bitwise-or %binary-file-flag (%reify-port port 11)))
  171.           port)))
  172.  
  173. (define open-output-file                  ; OPEN-OUTPUT-FILE
  174.      (lambda (name) (%open-port name 'write)))
  175.  
  176. (define open-binary-output-file                       ; OPEN-BINARY-OUTPUT-FILE
  177.      (lambda (name)
  178.         (let ((port (%open-port name 'write)))
  179.           (%reify-port! 
  180.             port
  181.             11 
  182.             (bitwise-or %binary-file-flag (%reify-port port 11)))
  183.       (set-line-length! 0 port)
  184.           port)))
  185.  
  186. (define open-extend-file                  ; OPEN-EXTEND-FILE
  187.      (lambda (name) (%open-port name 'append)))
  188.  
  189. (define close-input-port                   ; CLOSE-INPUT-PORT    
  190.      (lambda (port) (%close-port port)))
  191.  
  192. (define close-output-port                  ; CLOSE-OUTPUT-PORT
  193.      (lambda (port) (%close-port port)))
  194.  
  195.  
  196. (define (open-input-string str)             ; OPEN-INPUT-STRING
  197.   (if (string? str)
  198.       (let ((p (%make-window '())))
  199.     (%reify! p 0 str)
  200.     (%reify-port! p 2 3)
  201.     (%reify-port! p 11 (bitwise-and
  202.                  (bitwise-or %string-flag (%reify-port p 11))
  203.                  #xfd))
  204.     p)
  205.       (%error-invalid-operand 'OPEN-INPUT-STRING str)))
  206.  
  207.  
  208. (define output-port?                    ; OUTPUT-PORT?
  209.   (lambda (p)
  210.       (and (port? p)
  211.         (let ((pflags (%reify-port p 11)))
  212.           (and (positive? (bitwise-and %open-file-flag pflags))
  213.            (positive? (bitwise-and %write-file-flag pflags)))))))
  214.  
  215. (define (peek-char . p)
  216.   (let* ((char (apply read-char p)))
  217.     (if (not (eof-object? char))
  218.     (apply unread-char p))
  219.     char))
  220.  
  221. (define read                        ; READ
  222.   (letrec
  223.    ((rd-object
  224.      (lambda (port qq?)
  225.        (let ((item (read-atom port)))
  226.      (cond ((eof-object? item)   item)
  227.            ((atom? item)         item)
  228.            (else
  229.         (let ((item (car item)))
  230.           (case item
  231.             (|#(|  (rd-vector-tail port qq?))
  232.             ( |(|  (rd-list-tail port qq?))
  233.             ( |)|  (error "Unexpected `)' encountered before `('"))
  234.             ( |.|  (dot-warning) (rd-object port qq?))
  235.             ( |`|  (rd-mac port #T item #F))
  236.             ( |'|  (rd-mac port qq? item #F))
  237.             ((|[| |]| |{| |}|)
  238.                item)
  239.             (else  (rd-mac port qq? item #T)))))))))
  240.     (rd-mac
  241.      (lambda (port qq? item qq-op?)
  242.        (if (and (not qq?) qq-op?)
  243.        (error "Invalid outside of QUASIQUOTE expression:" item)
  244.        (let ((obj (rd-object port qq?)))
  245.          (if (eof-object? obj)
  246.          (eof-warning)
  247.          (list (cdr (assq item qq-ops)) obj))))))
  248.     (rd-vector-tail
  249.      (lambda (port qq?)
  250.        (list->vector (rd-tail port qq? #F '()))))
  251.     (rd-list-tail
  252.      (lambda (port qq?)
  253.        (rd-tail port qq? #T '())))
  254.     (rd-tail
  255.      (lambda (port qq? dot-ok? result)
  256.        (let ((item (read-atom port)))
  257.      (cond ((eof-object? item)
  258.         (eof-warning)
  259.         (%reverse! result))
  260.            ((atom? item)
  261.         (if (eq? item 'quasiquote)
  262.           (rd-tail port #T dot-ok? (cons item result))
  263.         ;else
  264.           (rd-tail port qq? dot-ok? (cons item result))))
  265.            (else
  266.         (let ((item (car item)))
  267.           (case item
  268.             ( |)|  (%reverse! result))
  269.             ( |.|  (if (and dot-ok? (not (null? result)))
  270.                    (rd-dotted-tail port qq? result)
  271.                    (begin
  272.                  (dot-warning)
  273.                  (rd-tail port qq? dot-ok? result))))
  274.             (else
  275.              (let ((obj (case item
  276.                   (|#(|  (rd-vector-tail port qq?))
  277.                   ( |(|  (rd-list-tail port qq?))
  278.                   ( |`|  (rd-mac port #T item #F))
  279.                   ( |'|  (rd-mac port qq? item #F))
  280.                   ((|[| |]| |{| |}|)
  281.                      item)
  282.                   (else  (rd-mac port qq? item #T)))))
  283.                (rd-tail port qq? dot-ok? (cons obj result)))))))))))
  284.     (rd-dotted-tail
  285.      (lambda (port qq? result)
  286.        (let ((tail (rd-tail port qq? #F '())))
  287.      (append! (%reverse! result)
  288.           (cond ((and (pair? tail)
  289.                   (null? (cdr tail)))
  290.              (car tail))
  291.             (else
  292.              (dot-warning)
  293.              tail))))))
  294.     (dot-warning
  295.      (lambda ()
  296.        (newline)
  297.        (display "WARNING -- Invalid use of `.' encountered during READ")))
  298.     (eof-warning
  299.      (lambda ()
  300.        (newline)
  301.        (display "WARNING -- EOF encountered during READ")
  302.        eof))
  303.     (qq-ops
  304.      '((|'|  . QUOTE)
  305.        (|`|  . QUASIQUOTE)
  306.        (|,|  . UNQUOTE)
  307.        (|,@| . UNQUOTE-SPLICING)
  308.        (|,.| . UNQUOTE-SPLICING!))))
  309.    (lambda args
  310.      (let ((port (car args)))
  311.        (rd-object port #F)))))
  312.  
  313. ;
  314. ; READ-LINE re-coded in assembly language on 2-10-86 by TC
  315. ;
  316. ;(define read-line                    ; READ-LINE
  317. ; (lambda args
  318. ;   (define (readln-rec port n char char-list)
  319. ;     (cond ((eof-object? char)
  320. ;         (if (null? char-list)
  321. ;         char
  322. ;         (fill-string (trim char-list))))
  323. ;        ((eqv? char #\return)
  324. ;         (if (null? char-list)
  325. ;         ""
  326. ;         (fill-string (trim char-list))))
  327. ;        ((eqv? char #\newline)
  328. ;         (readln-rec port n (read-char port) char-list))
  329. ;        (else
  330. ;         (readln-rec port (+ n 1) (read-char port)
  331. ;             (cons char char-list)))))
  332. ;   (define (trim char-list)
  333. ;     (cond ((null? char-list)
  334. ;         '())
  335. ;        ((eqv? (car char-list) #\space)
  336. ;         (trim (cdr char-list)))
  337. ;        (else
  338. ;         char-list)))
  339. ;   (define (fill-string char-list)
  340. ;     (let ((size (length char-list)))
  341. ;    (fill-rec char-list (- size 1) (make-string size '()))))
  342. ;   (define (fill-rec char-list i string)
  343. ;     (if (null? char-list)
  344. ;      string
  345. ;      (begin
  346. ;        (string-set! string i (car char-list))
  347. ;        (fill-rec (cdr char-list) (- i 1) string))))
  348. ;   (let ((port (and args (car args))))
  349. ;     (readln-rec port 0 (read-char port) '()))))
  350. ;
  351.  
  352. ; Extracted of reader.sw, by John D. Ramsdell, 90/07/12 ; READ-SW
  353. ; Converts SchemeWEB representations of Scheme objects 
  354. ; into the objects themselves much as READ does.  
  355.  
  356. (define (read-sw . rest)        ; Returns what \verb;read; returns.
  357.   (let ((port (if (pair? rest)        ; \verb;read-sw; arguments are
  358.           (car rest)        ; the same as \verb;read;'s.
  359.           (current-input-port))))
  360.     (letrec                
  361.     ((text-mode-and-saw-newline    ; Lines of a Scheme\WEB{} file
  362.       (lambda ()            ; beginning with ``{\tt(}'', 
  363.         (let ((ch (peek-char port))) ; start a code section.
  364.           (cond ((eof-object? ch) ch)
  365.             ((char=? ch #\()    ; If code section, then use
  366.              (got-code (read port))) ; \verb;read; to get code,
  367.             (else        ; else skip this line as it
  368.              (text-mode-within-a-line)))))) ; is a comment.
  369.      (text-mode-within-a-line
  370.       (lambda ()            ; Ignore comments.
  371.         (let ((ch (read-char port)))
  372.           (cond ((eof-object? ch) ch)
  373.             ((char=? ch #\newline)
  374.              (text-mode-and-saw-newline))
  375.             (else (text-mode-within-a-line))))))
  376.      (got-code
  377.       (lambda (code)        ; Ignore the remainder of the 
  378.         (let ((ch (read-char port))) ; last code line and return
  379.           (cond ((eof-object? ch) code) ;  the results of \verb;read;.
  380.             ((char=? ch #\newline)
  381.              code)
  382.             (else (got-code code)))))))
  383.     (text-mode-and-saw-newline)        ; Start by looking 
  384.     )))                    ; for a code line.
  385.  
  386.  
  387. (define set-line-length!                ; SET-LINE-LENGTH!
  388.   (lambda (value . rest)
  389.     (%reify-port! (car rest) 5 value)
  390.     '()))
  391.  
  392.  
  393. (define transcript-on)
  394. (define transcript-off)
  395.  
  396. (let ((port '()))
  397.   (set! transcript-on                    ; TRANSCRIPT-ON
  398.     (lambda (file)
  399.       (when (not (null? port))
  400.         (transcript-off))
  401.       (cond ((string? file)
  402.          (set! port (open-extend-file file))
  403.          (if (port? port)
  404.          (begin
  405.            (%transcript port)
  406.            'ok )
  407.          (begin
  408.            (set! port '())
  409.            (error "Unable to open transcript file" file))))
  410.         ((window? file)
  411.          (set! port file)
  412.          (%transcript file)
  413.          'ok)
  414.         (else
  415.          (error "Invalid argument to transcript-on" file)))))
  416.  
  417.   (set! transcript-off                    ; TRANSCRIPT-OFF
  418.     (lambda ()
  419.       (when (not (null? port))
  420.         (%transcript '())
  421.         (close-output-port port)
  422.         (set! port '()))
  423.       'ok)))
  424.  
  425. ;;; WITH-INPUT-FROM-FILE and WITH-OUTPUT-TO-FILE need to be rewritten
  426. ;;; to use DYNAMIC-WIND, or its equivalent.
  427.  
  428. (define with-input-from-file                ; WITH-INPUT-FROM-FILE
  429.   (lambda (filename thunk)
  430.     (let ((port (open-input-file filename)))
  431.       (if (port? port)
  432.       (let ((ans (fluid-let ((input-port port)) (thunk))))
  433.         (close-input-port port)
  434.         ans)
  435.       port))))
  436.  
  437. (define with-output-to-file                ; WITH-OUTPUT-TO-FILE
  438.   (lambda (filename thunk)
  439.     (let ((port (open-output-file filename)))
  440.       (if (port? port)
  441.       (let ((ans (fluid-let ((output-port port)) (thunk))))
  442.         (close-output-port port)
  443.         ans)
  444.       port))))
  445.  
  446. (define window?                        ; WINDOW?
  447.   (lambda (obj)
  448.     (and (port? obj)
  449.      (positive? (bitwise-and (%reify-port obj 11) %window-flag)))))
  450.  
  451. (define input-string?
  452.   (lambda (obj)
  453.     (and (window? obj)
  454.      (not (output-port? obj)))))
  455.  
  456. (define writeln                     ; WRITELN
  457.   (lambda args
  458.     (do ((args args (cdr args)))
  459.     ((null? args)
  460.      (newline))
  461.       (display (car args)))))
  462.  
  463. ;****************************************************************************
  464. ;* SET-FILE-POSITION will move the file pointer to a new position        *
  465. ;* and update a pointer in the buffer to point to a new location.        *
  466. ;* The offset variable can be:                            *
  467. ;*               0 for positioning from the start of the file        *
  468. ;*               1 for positioning relative to the current position   *
  469. ;*               2 for positioning from the end of the file        *
  470. ;****************************************************************************
  471.  
  472.   (define set-file-position!                   ; SET-FILE-POSITION! 
  473.     (lambda (port amount whence)
  474.       (let ((port-flags (%reify-port port 11)))
  475.     (cond ((input-string? port)
  476.            (let ((%set-pos
  477.                (lambda (pos)
  478.              (if (< pos 0)
  479.                  (%error-invalid-operand 'SET-FILE-POSITION! pos))
  480.              (%reify-port! port 9 0)        ; begin of buffer
  481.              (%reify-port! port 10 0)        ; empty buffer
  482.              (%reify-port! port 12 (+ pos 3))))); where to start reading
  483.          (case whence
  484.            ((0 SET) (%set-pos amount))
  485.            ((1 CUR) (%set-pos (+ (get-file-position port) amount)))
  486.            ((2 END) (%set-pos (- (string-length (%reify-port port 13)) amount)))
  487.            (else (%error-invalid-operand 'SET-FILE-POSITION! whence)))))
  488.  
  489.           ((and (port? port) (not (window? port)))
  490.            (let* ((file-size (+ (* (%reify-port port 4) #x10000)
  491.                     (%reify-port port 6)))
  492.               (%set-pos
  493.             (lambda (pos)
  494.               (if (= (bitwise-and port-flags %write-file-flag) 0)
  495.                   (set! pos (min pos file-size)))
  496.               (if (< pos 0)
  497.                   (%error-invalid-operand 'SET-FILE-POSITION! pos))
  498.               (let ((new-pos (remainder pos #x100))
  499.                 (old-chunk (max 0 (-1+ (%reify-port port 12))))
  500.                 (new-chunk (quotient pos #x100)))
  501.                 (if (and (= new-chunk old-chunk)
  502.                      (= (bitwise-and port-flags %write-file-flag) 0))
  503.                 (%reify-port! port 9 new-pos)
  504.                 (%sfpos port new-chunk new-pos))))))
  505.          (case whence
  506.            ((0 SET) (%set-pos amount))
  507.            ((1 CUR) (%set-pos (+ (get-file-position port) amount)))
  508.            ((2 END) (%set-pos (- file-size amount)))
  509.            (else (%error-invalid-operand 'SET-FILE-POSITION! whence)))))
  510.           (else (%error-invalid-operand 'SET-FILE-POSITION! port))))))
  511.  
  512. ;******************************************************************
  513. ;* get-file-position will return the current file position in the *
  514. ;* number of bytes from the beginning of the file.          *
  515. ;******************************************************************
  516.  
  517. (define get-file-position                ; GET-FILE-POSITION
  518.   (lambda (port)
  519.     (cond ((and (port? port) (not (window? port)))
  520.        (+ (* 256 (max 0 (-1+ (%reify-port port 12))))    ; chunk#
  521.           (%reify-port port 9)))                ; offset
  522.       ((input-string? port)
  523.        (+ (- (%reify-port port 12) 3 (%reify-port port 10))
  524.           (%reify-port port 9)))
  525.       (else (%error-invalid-operand 'GET-FILE-POSITION! port)))))
  526.  
  527.